;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
;;   Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
;;
;;   GNUnet is free software: you can redistribute it and/or modify it
;;   under the terms of the GNU Affero General Public License as published
;;   by the Free Software Foundation, either version 3 of the License,
;;   or (at your option) any later version.
;;
;;   GNUnet is distributed in the hope that it will be useful, but
;;   WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   Affero General Public License for more details.
;;
;;   You should have received a copy of the GNU Affero General Public License
;;   along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
;;   SPDX-License-Identifier: AGPL-3.0-or-later

;; Brief: publish an item of the store (GNU Guix) to GNUnet
;;
;; A quirk of the GNUnet's directory format to keep in mind:
;;  * the basename of the directory is saved in the .gnd
;;  * the basename of regular files that are published
;;     as-is isn't saved (but is included in the surrounding
;;     .gnd)
;;
;; The format used here is a SXML tree, as that seems most
;; simple to use with Guix' @code{write-file-tree}.

(library (gnu gnunet scripts publish-store)
  ;; XXX check exports
  (export main
	  store-item->sxml
	  directory->sxmls
	  publish-object
	  gnunet-publish)
  (import (rnrs base)
	  (rnrs io simple)
	  (ice-9 optargs)
	  (ice-9 getopt-long)
	  (gnu gnunet scripts guix-stuff)
	  (only (ice-9 ftw) scandir)
	  (only (srfi srfi-1) member)
	  (only (guile)
		basename
		readlink
		logand
		lstat
		stat:type
		stat:perms
		stat:size)
	  (guile)
	  (only (srfi srfi-1)
		concatenate)
	  (srfi srfi-26)
	  (srfi srfi-39)
	  (rnrs bytevectors)
	  (ice-9 binary-ports)
	  (ice-9 textual-ports)
	  (ice-9 regex)
	  (ice-9 popen)
	  (ice-9 rdelim)
	  (sxml match)
	  (only (ice-9 optargs)
		define*))
  (begin
    (define %options-specification
      `((version  (single-char #\v))
	(help     (single-char #\h))
	(format   (single-char #\f)
		  (value #t)
		  (predicate ,(cute member <> '("gnunet-nar-sxml/0"))))
	(input    (single-char #\i)
		  (value #t))
	(nar      (value #t))
	(simulate (single-char #\s))
	;; Debugging options
	(display-sxml)
	;; GNUnet options
	(config      (single-char #\c)
		     (value #t))
	(anonymity   (single-char #\a)
		     (value #t))
	(noindex     (single-char #\n))
	(priority    (single-char #\p)
		     (value #t))
	(replication (single-char #\r)
		     (value #t))))

    (define *simulate* (make-parameter #f))
    (define *display-sxml* (make-parameter #f))
    (define *config*
      (make-parameter (string-append (getenv "HOME")
				     "/.config/gnunet.conf")))
    (define *anonymity* (make-parameter 1))
    (define *priority* (make-parameter 360))
    (define *replication* (make-parameter 0))
    (define *no-index* (make-parameter #f))

    (define (call-with-options options thunk)
      "Call the thunk @var{thunk} in an environment where
the options @var{options} are applied."
      (define opt (cute option-ref options <> <>))
      (define (num sym default)
	(let ((value/str (opt sym #f)))
	  (if value/str
	      (string->number value/str)
	      default)))
      (parameterize ((*simulate* (opt 'simulate (*simulate*)))
		     (*display-sxml* (opt 'display-sxml (*display-sxml*)))
		     (*config* (opt 'config (*config*)))
		     (*anonymity* (num 'anonymity (*anonymity*)))
		     (*priority* (num 'priority (*priority*)))
		     (*replication* (num 'replication (*replication*)))
		     (*no-index* (opt 'noindex (*no-index*))))
	(thunk)))

    (define %help
      "Usage: publish-store --input=INPUT --config=CONFIG [OPTION]...
Publish a (GNU Guix, or Nix) store item INPUT into GNUnet.

  -v, --version    Print version information
  -h, --help       Print this message
  -s, --simulate   Do not actually publish INPUT, only print the
                   computed URI
  -f, --format     Format for representing a store item,
                   currently gnunet-nar-sxml/0
  -i, --input      Store item to publish
      --nar        Publish a nar instead

Debugging options
      --display-sxml  Display generated SXML to stdout

GNUnet options
  -c, --config       GNUnet configuration for publishing
  -a, --anonymity    Anonymity level for publishing
  -p, --priority     Priority level for publishing (360 by default)
  -r, --replication  Desired replication level (0 by default)
  -n, --noindex      Do not store files by name in the local GNUnet")

    (define (main arguments)
      (inner-main arguments)
      (exit 0))

    (define (inner-main arguments)
      (let ((options (getopt-long arguments %options-specification)))
	(cond ((option-ref options 'version #f)
	       (display "scheme-gnunet publish-store v0.0"
			(current-output-port))
	       (newline (current-output-port)))
	      ((option-ref options 'help #f)
	       (display %help (current-output-port))
	       (newline (current-output-port)))
	      ((equal? (option-ref options 'format "gnunet-nar-sxml/0")
		       "gnunet-nar-sxml/0")
	       (let ((result
		      (call-with-options
		       options
		       (lambda ()
			 (publish-nar/sxml/1
			  #:input (option-ref options 'input #f))))))
		 (format (current-output-port)
			 "Published at ~a in ~a format~%"
			 result "gnunet-nar-sxml/0")))
	      (else ???))))

    (define* (publish-nar/sxml/1 #:key input)
      (let* ((sxml (store-item->sxml input))
	     (sxml/hashed (sxml-publish-leaves! sxml #:include-name? #f)))
	(when (*display-sxml*)
	  (write (current-output-port) sxml/hashed))
	(publish-object (string->utf8 (object->string sxml/hashed)))))

    (define gnunet-publish-uri-regexp
      (make-regexp "\\b(gnunet://fs/chk/([A-Z0-9]+).([A-Z0-9]+).[0-9]+)\\b"))
    (define (extract-uri output)
      (match:substring (regexp-exec gnunet-publish-uri-regexp output) 1))

    (define (gnunet-publish file)
      "Run the GNUnet publish binary, and return the computed hash
as a string."
      (setenv "LC_ALL" "C")
      (let* ((*binary* "gnunet-publish")
	     ;; FIXME for some reason
	     ;; setting anonymity to 0
	     ;; causes a hang
	     (anonymity (if (= (*anonymity*) 0)
			    1
			    (*anonymity*)))
	     (cmd `(,*binary*
		    "--disable-extractor"
		    "-a" ,(number->string anonymity)
		    "-p" ,(number->string (*priority*))
		    "-r" ,(number->string (*replication*))
		    ,@(if (*config*)
			  `("-c" ,(*config*))
			  '())
		    ,@(if (*simulate*)
			  '("-s")
			  '())
		    ,@(if (*no-index*)
			  '("-n")
			  '())
		    "--"
		    ,file))
	     (pipe (apply open-pipe* OPEN_READ cmd))
	     (text-0 (read-line pipe))
	     (text-1 (read-line pipe))
	     (ret  (close-pipe pipe)))
	(unless (= ret 0)
	  ;; XXX
	  (throw 'gnunet-publish-eep 'gnunet-publish-???))
	(extract-uri text-1)))

    (define* (sxml-publish-leaves! sxml #:key (include-name? #t))
      "Publish SXML, an SXML as returned by store-item->sxml,
and return a SXML where the on-disk filenames are replaced
by the corresponding GNUnet URIs.  If INCLUDE-NAME? is false,
the name of the top-level entry is not included in the returned
SXML."
      (define (maybe-name name)
	(if include-name?
	    `((name ,name))
	    '()))
      (sxml-match sxml
		  ((regular (@ (name ,name)
			       (executable? ,executable?)
			       (data-from-file ,filename)))
		   `(regular (@ ,@(maybe-name name)
				(executable? ,executable?)
				(hash ,(publish-object filename)))))
		  ((symlink (@ (name ,name)
			       (target ,target)))
		   `(symlink (@ ,@(maybe-name name)
				(target ,target))))
		  ((directory (@ (name ,name))
			      . ,rest)
		   `(directory (@ ,@(maybe-name name))
			       . ,(map sxml-publish-leaves! rest)))))

    (define (publish-object data)
      "Publish DATA, a bytevector or filename, and return
the resulting GNUnet FS URI. If SIMULATE is #t, do not
actually publish the file, only compute its hash."
      (cond ((bytevector? data)
	     (call-with-temporary-output-file
	      (lambda (name port)
		(put-bytevector port data)
		(close-port port)
		(parameterize ((*no-index* #t))
		  (gnunet-publish name)))))
	    ((string? data) (gnunet-publish data))))

    (define (store-item->sxml filename)
      (let* ((name  (basename filename))
	     (stat  (lstat filename))
	     (type  (stat:type stat))
	     (perms (stat:perms stat))
	     (executable?
	      (= (logand perms #o0001)
		 #o0001)))
	(case (stat:type stat)
	  ((regular)
	   `(regular (@ (name ,name)
			(size ,(stat:size stat))
			(executable? ,executable?)
			(data-from-file ,filename))))
	  ((directory)
	   `(directory (@ (name ,name))
		       ,@(directory->sxmls filename)))
	  ((symlink)
	   `(symlink (@ (name ,name)
			(target ,(readlink filename)))))
	  (else ???))))

    (define (directory->sxmls filename)
      (let ((names (scandir filename
			    (lambda (n)
			      (not (member n '("." ".."))))
			    string<?)))
	(map (lambda (name)
	       (let ((file (string-append filename "/" name)))
		 (store-item->sxml file)))
	     names)))))

